home *** CD-ROM | disk | FTP | other *** search
/ SuperHack / SuperHack CD.bin / CODING / MISC / MAG10.ZIP / VECTOR2.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1996-08-26  |  8.0 KB  |  227 lines
  1.                Program VectorBalls;
  2.  
  3.                Uses Mode13h,Crt;
  4.  
  5.                Type BallSprite=Array[1..8,1..8] Of Byte;
  6.  
  7.                Const Balls=43;
  8.                      { Base object }
  9.                      Ball:BallSprite=
  10.                      ((0,0,2,2,2,1,0,0),(0,2,3,3,3,2,1,0),(2,3,4,3,3,2,1,1),
  11.                       (2,3,3,3,2,2,1,1),(2,2,3,3,2,1,1,1),(1,2,2,2,1,1,1,1),
  12.                       (0,1,1,1,1,1,1,0),(0,0,1,1,1,1,0,0));
  13.  
  14.                Type Ball3d=Record
  15.                                  Color:Byte;
  16.                                  X,Y,Z:Real;
  17.                            End;
  18.  
  19.                Var S:Array[1..Balls] of Ball3d;
  20.                    A:Integer;
  21.                    C:Char;
  22.  
  23.                Procedure InitColors;
  24.                { Sets the colors }
  25.                Begin
  26.                     SetColor(0,0,0,0);
  27.                     { Blues }
  28.                     SetColor(1,0,0,30);
  29.                     SetColor(2,0,0,50);
  30.                     SetColor(3,0,20,63);
  31.                     SetColor(4,0,40,63);
  32.                     { Yellows }
  33.                     SetColor(5,63,25,0);
  34.                     SetColor(6,63,50,0);
  35.                     SetColor(7,63,63,0);
  36.                     SetColor(8,63,63,63);
  37.                     { Greens }
  38.                     SetColor(9,0,20,0);
  39.                     SetColor(10,0,40,0);
  40.                     SetColor(11,0,50,0);
  41.                     SetColor(12,0,63,0);
  42.                     { Browns }
  43.                     SetColor(13,63,20,0);
  44.                     SetColor(14,63,30,0);
  45.                     SetColor(15,63,40,0);
  46.                     SetColor(16,63,50,0);
  47.                End;
  48.  
  49.                Procedure LoadVector(Filename:String);
  50.                { Loads a vector object from disk... The objects may be
  51.                  generated with the VECTGEN.PAS program... }
  52.                Var F:Text;
  53.                    A,N:Byte;
  54.                Begin
  55.                     Assign(F,Filename);
  56.                     Reset(F);
  57.                     ReadLn(F,N);
  58.                     For A:=1 To N Do
  59.                     Begin
  60.                          ReadLn(F,S[A].X);
  61.                          ReadLn(F,S[A].Y);
  62.                          ReadLn(F,S[A].Z);
  63.                          ReadLn(F,S[A].Color);
  64.                     End;
  65.                     Close(F);
  66.                End;
  67.  
  68.                Procedure DrawSprite(X,Y:Integer;BaseColor:Byte;Where:Word);
  69.                Var A,B:Byte;
  70.                Begin
  71.                     For A:=1 To 8 Do For B:=1 To 8 Do
  72.                       If Ball[A,B]<>0 Then
  73.                         PutPixel(X+A-1,Y+B-1,Ball[A,B]+BaseColor-1,Where);
  74.                End;
  75.  
  76.                Procedure DrawBall(P:Ball3d;Where:Word);
  77.                Var Xt,Yt:Integer;
  78.                Begin
  79.                     { Convert X,Y,Z to X,Y }
  80.                     Xt:=160+Trunc((P.X*256)/P.Z);
  81.                     If (Xt<0) Or (Xt>319) Then Exit;
  82.                     Yt:=100+Trunc((P.Y*256)/P.Z);
  83.                     If (Yt<0) Or (Yt>199) Then Exit;
  84.                     { Draw the ball }
  85.                     DrawSprite(Xt,Yt,P.Color,Where);
  86.                End;
  87.  
  88.                Procedure Sort;
  89.                Var Flag:Boolean;
  90.                    I,J:Integer;
  91.                    N:Real;
  92.                    X:Ball3d;
  93.  
  94.                    Procedure SortSubArray(Left,Right:Byte);
  95.                    Begin
  96.                         { Partition }
  97.                         I:=Left;
  98.                         J:=Right;
  99.                         N:=S[(Left+Right) Div 2].Z;
  100.                         Repeat
  101.                               { Find first number from the left to be < N }
  102.                               While S[I].Z<N Do Inc(I);
  103.                               { Find first number from the right to be > N }
  104.                               While S[J].Z>N Do Dec(J);
  105.                               { Exchange }
  106.                               If I<=J Then
  107.                               Begin
  108.                                    X:=S[J];
  109.                                    S[J]:=S[I];
  110.                                    S[I]:=X;
  111.                                    Inc(I);
  112.                                    Dec(J);
  113.                               End;
  114.                         Until J<I;
  115.                         { Order left and right subarrays }
  116.                         If Left<J Then SortSubArray(Left,J);
  117.                         If I<Right Then SortSubArray(I,Right);
  118.                    End;
  119.  
  120.                Begin
  121.                     SortSubArray(1,Balls);
  122.                End;
  123.  
  124.                Procedure DrawBalls(Where:Word);
  125.                Var A:Byte;
  126.                Begin
  127.                     Sort;
  128.                     For A:=Balls DownTo 1 Do DrawBall(S[A],Where);
  129.                End;
  130.  
  131.                Procedure RotateX(Deg:Integer);
  132.                Var A:Byte;
  133.                    Angle:Real;
  134.                    ZTemp:Real;
  135.                    Si,Co:Real;
  136.                Begin
  137.                     Angle:=0.0175*Deg;
  138.                     Si:=Sin(Angle);
  139.                     Co:=Cos(Angle);
  140.                     For A:=1 To Balls Do
  141.                       With S[A] Do
  142.                       Begin
  143.                            ZTemp:=Z;
  144.                            Z:=ZTemp*Co-Y*Si;
  145.                            Y:=Y*Co+ZTemp*Si;
  146.                       End;
  147.                End;
  148.  
  149.                Procedure RotateY(Deg:Integer);
  150.                Var A:Byte;
  151.                    Angle:Real;
  152.                    XTemp:Real;
  153.                    Si,Co:Real;
  154.                Begin
  155.                     Angle:=0.0175*Deg;
  156.                     Si:=Sin(Angle);
  157.                     Co:=Cos(Angle);
  158.                     For A:=1 To Balls Do
  159.                       With S[A] Do
  160.                       Begin
  161.                            XTemp:=X;
  162.                            X:=XTemp*Co-Z*Si;
  163.                            Z:=Z*Co+XTemp*Si;
  164.                       End;
  165.                End;
  166.  
  167.                Procedure RotateZ(Deg:Integer);
  168.                Var A:Byte;
  169.                    Angle:Real;
  170.                    XTemp:Real;
  171.                    Si,Co:Real;
  172.                Begin
  173.                     Angle:=0.0175*Deg;
  174.                     Si:=Sin(Angle);
  175.                     Co:=Cos(Angle);
  176.                     For A:=1 To Balls Do
  177.                       With S[A] Do
  178.                       Begin
  179.                            XTemp:=X;
  180.                            X:=XTemp*Co-Y*Si;
  181.                            Y:=Y*Co+XTemp*Si;
  182.                       End;
  183.                End;
  184.  
  185.                Procedure Rotate(XRot,YRot,ZRot:Integer);
  186.                Begin
  187.                     RotateX(XRot);
  188.                     RotateY(XRot);
  189.                     RotateZ(XRot);
  190.                End;
  191.  
  192.                Procedure Move(XOff,YOff,ZOff:Integer);
  193.                Begin
  194.                     For A:=1 To Balls Do
  195.                     Begin
  196.                          S[A].X:=S[A].X+XOff;
  197.                          S[A].Y:=S[A].Y+YOff;
  198.                          S[A].Z:=S[A].Z+ZOff;
  199.                     End;
  200.                End;
  201.  
  202.                Begin
  203.                     { Setup program }
  204.                     InitGraph;
  205.                     InitVirt;
  206.                     InitColors;
  207.                     LoadVector('Island.Vct');
  208.                     { Move it further away }
  209.                     Move(0,0,256);
  210.                     Cls(0,VGA);
  211.                     Cls(0,VP[1]);
  212.                     { Main cicle }
  213.                     Repeat
  214.                           { Clear virtual screen }
  215.                           Cls(0,VP[1]);
  216.                           Move(0,0,-256);
  217.                           Rotate(5,-10,10);
  218.                           Move(0,0,256);
  219.                           { Draw balls }
  220.                           DrawBalls(VP[1]);
  221.                           { Copy virtual screen to VGA screen }
  222.                           CopyPage(VP[1],VGA);
  223.                     Until Keypressed;
  224.                     { Shutdown }
  225.                     CloseVirt;
  226.                     Closegraph;
  227.                End.